00100	C***** SUBRS RHYTH, NOTNUM, DOTS  ********  
00200	
00300		SUBROUTINE RHYTH
00400		COMMON/RINP/R(10,85),POSNT(0/99)
00500		1 /RMOD/RMODE2,SET4,IBEAM,NOSET,STEM,STUP,NTC,PS2,
00600		1 RA,RDD,ITB,POSB /PTR/KWDS(1) /FRMT/FQZ(3),IREAD
00700		1 /XRN/RN(1) /IDEV/IDEV
00800		1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
00900		1 /SCX/JALPHA(30),JX,JXX,JZ,IRHY,JD,KA,KB,IZ
01000		1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,
01100		1 NFLG,KXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
01200		1 /ALF/INP(59),NX,NOTE,JSET,KZ,KX,AVGPOS,RLPOS,RLP2,
01300		1 AVP2,ZX,RE,ZZ,RD,RSTX
01400	C   SEE ALSO FILLMS, SETLET AND SETUP  RE. /FLM/
01500		DIMENSION RPOS(2,100)
01600		COMMON R2,JH,CENTR,J2,R3,R4,R5,RJQ(17),J3,JQ(19)
01700		1 /DPY/ST(4000),MEDIT,GO /LIMIT/LIMIT,ITEM,NL,NO,NONO
01800		1 /POS/POS1,POS2 /STF/RSTFAC(0/7),RSTJ2
01900		EQUIVALENCE (VX(1),X),(VX(2),Y),(VX(7),Z),(RPOS,ST(3400))
02000		1,(VX(3),AB),(VX(4),T),(VX(5),RB),(VX(6),X2)
02100		1,(VX(8),C),(VX(9),S),(VX(10),X3)
02200	
02300	CCC	DATA FIB/.75/
02400	C  FIB IS FOR PSUEDO-FIBONACCI SPACING
02500		RSTJ3=RSTFAC(IFIX(STAFF))
02600		POSNT(0)=-1
02700		POSNT(1)=-1
02800	C IN CASE 1ST NOTE IS AT POS. ZERO
02900		NX=-1
03000		JX=0
03100		T=0
03200		Y=0
03300		NOTE=0
03400		ICNTPT=-1
03500		NOSET=0
03600		JSET=0
03700	C  STUP IS NEG. IF SETUP IS NOT READY
03800		IF(STUP)GO TO 341
03900		IF(SET4.NE.STAFF)GO TO 70
04000		NOSET=-1
04100	C  TO ADD MORE NOTES ON SETUP LINE. WIPES OUT P9 AT END OF SCMSS.
04200		GO TO 270
04300	70	DO 370 K=1,ITEM-IZ-1
04400	C LOOKS ONLY AT THINGS BEFORE CURRENT INPUT.
04500		J=KWDS(K)
04600		IF(RN(J+1).GT.2)GO TO 370
04700		IF(RN(J+2).EQ.STAFF)GO TO 270
04800	370	CONTINUE
04900		GO TO 170
05000	270	ICNTPT=0
05100	C THIS WILL CAUSE NOTES ADDED TO LINE TO HAVE NO RHYTH VAL IN P9
05200	170	KZ=1
05300		POS2=PS2
05400	C  GETS LAST ↑↑ POS. FROM SETUP
05500		JSET=-1
05600	C  NEXT NUM.(100) IS LIMIT FOR STF.4 (CAN BE UP TO 300-SEE /FLM/)
05700		DO 9 KX=1,100
05800	9	IF(RPOS(2,KX).GE.0)GO TO 10
05900	10	AVGPOS=RPOS(1,KX)
06000		RLPOS=AVGPOS
06100	344	KX=KX+1
06200		IF(RPOS(2,KX).EQ.-3)GO TO 344
06300	C**** IGNORES CLEFS (BUT NOT BARS) IN AUTOMATIC SPACING ***** 10/76
06400		RLP2=RPOS(1,KX)
06500	343	AVP2=RPOS(2,KX)-.001
06600		IF(AVP2.GT.0)GO TO 341
06700		KX=KX+1
06800		GO TO 343
06900	C  AVERAGED AND REAL POSITIONS FROM 'SETUP'
07000	
07100	C  NEXT FOR NON-SETUP
07200	341	DO 34 K=1,IRHY
07300		CALL DOTS(VAL,RH,K,DOT)
07400	C VAL=RHYTH. VALUE (QTR=1), RH=DENOMINATOR (QTR=4), DOT=NUM OF DOTS
07500	C  88TH NOTES ARE TAKEN AS GRACE NOTES. THEN BECOME 32NDS.
07600		IF(RH.NE.88)GO TO 345
07700		IF(JSET)GO TO 34
07800	C  GRACE NOTES SKIPPED IN AUTOMATIC SETUP
07900		VAL=.1    
08000	CFIB345	IF(STUP.LT.-1)VAL=PFIBX(VAL)
08100	345	IF(STUP.LT.-1)VAL=14.0*EXP(ALOG(VAL)*0.5849624)
08200	C THIS IS EXP((ALOG(A)/ALOG(2.0))*ALOG(1.5))  NOT FIBBONACI (1.618)
08300	CCC345	IF(STUP.LT.-1)Z=Z+(.125-Z)*FIB
08400	C  STUP CAN BE SET TO .LT.-1 IN NOTBMS FOR PSUEDO-FIBONACCI SPACE
08500		Y=Y+VAL
08600	34	CONTINUE
08700	C  Y=TOTAL TIME
08800	C A SAFEGUARD
08900	C  SAVES POS1 FOR POSITIONING MF, CRESC. ETC.
09000		NTC=0
09100	C  THE WORD COUNT FOR REAL NOTES.
09200		IF(JSET)GO TO 3421
09300	
09400		IF(POS1.LT.POS2)POSX=POS1
09500	C  SAVES IT FOR BACKUP
09600		IF(POS1.GE.POS2)POS1=POSX
09700	
09800		Z=POS2-POS1
09900		ZX=Z
10000	342	DO 1 K=1,IZ
10100		X=R(1,K)
10200		IF(X.LT.3.)GO TO 1
10300	C  JUMP IF NOTE OR REST
10400		IF(X.NE.17.)GO TO 8
10500	C   JUMP IF NOT A KEY SIG.
10600		RA=AMOD(R(5,K),100.0)
10700	C  100+KEY SIG NUM  =  SIG MADE UP OF NATURALS.
10800		RA=2.+ABS(RA)*2.0
10900		IF(K.GT.1)R(8,K-1)=R(8,K-1)+RSTJ3
11000	C PUSH KSIG 1*SIZE TO RIGHT OF PREVIOUS ITEM.
11100		GO TO 6
11200	8	IF(X.NE.4.)GO TO 81
11300	C   NEXT IS FOR BAR LINES
11400		RA=3
11500		J=K+1
11600		RE=R(1,J)
11700		IF(RE.EQ.3.)RA=1.5
11800	C  A CLEF
11900		IF(RE.EQ.18)RA=2.5
12000	C  A METER
12100		IF(RE.NE.1)GO TO 83
12200		IF(AMOD(R(5,J),10.).NE.0)RA=4.5
12300	C  FINDS ACCI ON NEXT NOTE.
12400	83	IF(K.EQ.IZ)RA=0
12500	C  END OF STAFF
12600		GO TO 6
12700	82	RA=5
12800	CGHB82	RA=6
12900		GO TO 83
13000	81	IF(X.EQ.18)GO TO 82
13100		RA=6.
13200		IF(K.LT.3)RA=8.
13300	CGHB	RA=7.
13400	C   FOR CLEFS
13500	CGHB	IF(K.LT.3)RA=9.
13600	C   THE FIRST CLEF IS NOT MINI
13700	6	RA=RA*RSTJ3
13800	C  SO SPACE WILL DEPEND ON SIZE OF STAFF
13900		Z=Z-RA
14000		R(8,K)=RA
14100	C   STORES SPACE NUM THAT MUST BE GIVEN BACK
14200	1	CONTINUE
14300	C   SUBTRACTS SPACE FOR CLEF OR BAR.  WILL ADD BOTH LATER.
14400	C  POS1 AND Z ARE FOR RHYTHMIC SPACING
14500	C  SPACE FOR NON-NOTES
14600	3421	K=0
14700		IF(ABS(Y-RA).LE..001)GO TO 3
14800		IF(JSET)CALL MISMCH(RA,Y)
14900	C TYPES MISMATCH MESSAGE
15000	
15100	C   LOOP TO END
15200	3	K=K+1
15300	C   K IS COUNTER
15400		T=0
15500	CXX	R(7,K)=0
15600		RE=R(1,K)
15700		IF(RE.LE.2.)GO TO 2
15800		RD=R(8,K)
15900		R(8,K)=0
16000		IF(JSET)GO TO 71
16100	
16200	7	IF(K.EQ.IZ)POS1=POS2
16300		IF(R(1,K-1).GT.2.)GO TO 73
16400		IF(K.EQ.1)GO TO 73
16500		IF(RE.EQ.4.)GO TO 73
16600		Z=Z+RD/3.
16700	C   RETURNS 1/3 OF THE SPACE IF PREV. ITEM IS NOTE OR REST
16800		POS1=POS1-RD/3
16900	C  THIS CAN RESULT IN OVERLAP WHICH MUST BE EDITED OUT.!!
17000	73	R(3,K)=POS1
17100	72	POS1=POS1+RD
17200	C   ABOVE SECTION LEAVES ROOM FOR CLEF OR BAR
17300		GO TO 337
17400	
17500	C  40???   50????  WHY NOT 100?
17600	71	DO 74 J=KZ,80
17700	74	IF(RE.EQ.-RPOS(2,J))GO TO 75
17800		POS=R(3,K-1)+4
17900		GO TO 76
18000	75	POS=RPOS(1,J)
18100		KZ=J+1
18200	C  FOUND SAME TYPE OF ITEM.
18300	76	R(3,K)=POS
18400		GO TO 337
18500	
18600	2	JX=JX+1
18700	21	CALL DOTS(VAL,RH,JX,DOT)
18800		V(JX)=VAL
18900		IF(RE.NE.2)GO TO 121
19000		V(JX)=-VAL
19100	C  SHOWS RESTS IN AUTO. BEAM SECTION.(ASSUMES REST WAS A + NUMB.)
19200		R(7,K)=VAL
19300		GO TO 210
19400	121	IF(R(8,K).GE.-1.)R(9,K)=VAL
19500	C  STORES RHYTH VALUE FOR LATER USE IN PART EXTRACTOR IF NOT CHORD NOTE.
19600	CCC	IF(AB.GT..05)GO TO 210
19700		IF(RH.NE.88.)GO TO 210
19800		R(3,K)=-1.
19900		R(4,K)=R(4,K)+100.
20000	C  WILL THIS BE OK WITH NOTES BELOW B3 (I.E. NEG POSITIONS.
20100		R(7,K)=1
20200	C  FOUND A GRACE NOTE  (88TH NOTE)   
20300		RB=4./88.
20400		R(9,K)=RB    
20500		JZ=1
20600		IF(STEM.GE.0)GO TO 1211
20700		IF(R(9,K-1).EQ.RB)GO TO 1211
20800	4211	IF(V(JX+1).EQ.88..AND.R(1,K+1).EQ.1)GO TO 1211
20900	C  STEM WILL BE UP UNLESS PRESET OR TWO OR MORE IN A ROW.
21000		IF(R(5,K).GE.20.)R(5,K)=R(5,K)-10.
21100	C NOW STEM IS UP
21200	
21300	1211	IF(R(8,K+JZ).GE.0)GO TO 211
21400		J=K+JZ
21500	C GRACE NOTE CHORDS
21600		R(3,J)=-1
21700	C  FOR AUTO-SPACING AT 337
21800		R(4,J)=R(4,J)+100.
21900	C MAKE IT A MINI-NOTE
22000		R(8,K)=1000.+ABS(R(4,K)-R(4,J))
22100	C  EXTEND THE STEM
22200		JZ=JZ+1
22300	C  FOR MORE CHORD NOTES.  SHOULD I CHECK FOR END (IZ)?
22400		GO TO 1211
22500	C  ** NOT NOW ***TURNS STEM OVER. UNLESS STEM DIRECTIONS WERE FIXED.(SU/SD/)
22600	211	IF(JZ.LE.1)R(8,K)=1000
22700	2211	IF(JSET.GE.0)GO TO 3211
22800		K=K+JZ-1
22900	C  POS WILL BE SET AT 336
23000		NTC=NTC+1
23100	C  UPDATE THE COUNTER FOR IMPORTANT POSITIONS. POSNT SET AT 336
23200		POSNT(NTC)=-1
23300		GO TO 337
23400	3211	VAL=.1    
23500	C IT USED TO JUMP.  NOW MAKES SPACE FOR GRACE NOTES AS 32NDS.
23600	210	RB=0
23700	C  FOR AUTOMATIC SETUP
23800		JZ=K
23900	C  JZ WILL BE USED NEAR END
24000	CC3634	IF(AMOD(AB,.1875).EQ.0)GO TO 122
24100	CC	T=IDOT*10
24200	C IDOT IS NUM OF DOTS
24300		IF(RE.EQ.2.)GO TO 35
24400		IF(RH.EQ.88)GO TO 22
24500	CXX	T=0
24600		IF(RH.LT.8)GO TO 522
24700	CC	IF(R(5,K).LT.10)GO TO 422
24800	C DON'T ADD TAILS TO STEMLESS NOTE. (IT CONFUSES 'BEAMS')
24900		T=IFIX(ALOG(RH)/0.6931472+.001)-2.0
25000	C RH=8=1 TAIL,  16=2TAILS, ETC. THE NUM. (8,16) IS RESULT OF 2 TO THE NTH.
25100	522	RB=0
25200		IF(DOT.EQ.0)GO TO 422
25300		IF(R(6,K).GE.20)RB=100 
25400	C  TO SHIFT DOT DOWN 2 STEPS
25500	422	R(7,K)=T+RB+DOT
25600		T=0
25700	cc422	R(7,K)=T+IDOT
25800	C  PUTS ONE OR MORE DOTS
25900	CC	GO TO 36
26000		GO TO 22
26100	
26200	35	IF(R(6,K).GE.0)GO TO 135
26300		R(6,K)=-1
26400		GO TO 22
26500	C  ADDS DOT TO REST. (IF R6 IS -2. = INVIS. REST. CHANGE IT TO -1)
26600	135	IF(R(8,K).EQ.0)R(6,K)=DOT/10.
26650	C  NO DOTS ON 'WHOLE MEASURE' RESTS
26700	CC35	R(6,K)=T/10.
26800	CC36	RB=VAL/3.
26900	CC	IF(T.NE.1)RB=(4*VAL)/7
27000	C  TO KEEP TAIL ON DOTTED NOTE
27100	
27200	22	POS=POS1
27300		IF(R(6,K).GE.30)R(6,K)=R(6,K)-30
27400	C  30 NEEDED FOR SOME CASES WITH DOTS ON CHORDS.
27500		IF(JSET.EQ.0)GO TO 220
27600	
27700	C  NEXT IS FOR SETUP
27800	222	IF(NOTE)GO TO 223
27900	C  FIRST TIME A NOTE IS FOUND.
28000		NOTE=-1
28100		POS1=RLPOS
28200		Z=POS2-POS1
28300	C  RESETS SPACE AVAILABLE, ZZ IS SPACE FOR NON-NOTES
28400	223	IF(POS1.LT.AVP2)GO TO 221
28500	224	KX=KX+1
28600	C???? OCT, 73	 	IF(NX.EQ.0)GO TO 225
28700		L=KX
28800	1228	IF(RPOS(2,L).NE.-3)GO TO 228
28900		L=L+1
29000	C  IGNORE CLEFS (BUT NOT BARS) ********* 10/76
29100		GO TO 1228
29200	228	IF(NX)RLP2=RPOS(1,L)
29300		NX=-1
29400	225	IF(RPOS(2,KX-1))GO TO 227
29500		RLPOS=RPOS(1,KX-1)
29600		AVGPOS=AVP2
29700	227	AVP2=RPOS(2,KX)-.001
29800		IF(AVP2.GT.0)GO TO 223
29900	C  0 IN RPOS=POS. OF NON-NOTE
30000	CC****** WHY NEEDED?? 6/74 ***	IF(RLP2.GE.POS1)NX=0
30100		NX=0
30200	CC*****↑↑↑↑ CHANGED FROM ABOVE ***  6/74
30300		GO TO 224
30400	221	POS=(POS1-AVGPOS)*(RLP2-RLPOS)/(AVP2-AVGPOS)+RLPOS
30500	220	R(3,K)=POS
30600	4634	IF(RE.NE.1)GO TO 44
30700		IF(POS.EQ.POSNT(NTC))GO TO 2634
30800	C  SKIPS OTHER CHORD NOTES.
30900		NTC=NTC+1
31000		POSNT(NTC)=POS
31100	C  SAVES IT FOR NUMBS ABOVE NOTES, ETC.
31200	2634	IF(RH.LT.4)GO TO 4
31300	C JUMP IF DENOM. IS LESS THAN 4.  I.E. 1/2 NOTE ETC.
31400	44	L=K+1
31500		IF(R(8,L).GE.0)GO TO 1634
31600		IF(R(1,L).NE.1.)GO TO 1634
31700	C   JUMP IF NOT DOUBLE STOP
31800	C  DELETES STEM FROM WHOLE NOTE CHORD (NOW DONE IN NOTWRT IF P7=1)
31900		R(3,L)=R(3,K)
32000		K=L
32100	CC	R(8,K)=0
32200		GO TO 522 
32300	C  LOOPS BACK TO PICK UP MORE CHORD NOTES
32400	
32500	C 'WHITENS' HALF, WHOLE AND TRIPLET HALF NOTES.
32600	4	RA=-R(6,K)
32700		IF(RA.EQ.0)RA=-1
32800		IF(RH.GE.2.)GO TO 144
32900		R(5,K)=AMOD(R(5,K),10.0)
33000	C  TAKES STEM INFO OFF ANYTHING LONGER THAN 1/2 NOTES -- FOR SLUR ROUTINE.
33100		RP=1
33200		IF(RH.LE..5)RP=2
33300		R(7,K)=R(7,K)+RP
33400	C  +1=WHOLE NOTE WILL PRINT  +2=DBL WHL NT.
33500	CC NOT NEEDED BECAUSE OF ABOVE. 	RA=-2.
33600	144	R(6,K)=RA
33700		GO TO 44
33800	
33900	1634	T=POS1
34000		RP=VAL
34100	CFIB	IF(STUP.LT.-1)RP=PFIBX(VAL)
34200		IF(STUP.LT.-1)RP=14.0*EXP(ALOG(RP)*0.5849624)
34300	C THIS IS EXP((ALOG(A)/ALOG(2.0))*ALOG(1.5))  NOT FIBBONACI (1.618)
34400	CCC	IF(STUP.LT.-1)RP=AB+(.125-AB)*FIB
34500	C  FOR PSUEDO-FIB. SPACING
34600		POS1=RP/Y*Z+POS1
34700	535	IF(R(1,JZ).EQ.1.)GO TO 337
34800		RA=R(4,JZ)
34900	C  SETS REST
35000		IF(R(8,JZ).NE.0.1)GO TO 537
35100		T=-4
35200	C*****	R(8,JZ)=-2
35300	C  -2 CENTERS THE SIGN UNDER THE RIGHT CONDITIONS
35400		GO TO 536
35500	CC537	IF(VAL.LT.2)GO TO 538
35600	CC	T=-1
35700	CC	IF(RH.LT.2)T=-2
35800	CC	IF(RH.LT.1)T=-3
35900	C  -1=HLF RST, -2=WHOLE, -3=DBL WHL RST, -4=REPEAT BAR SIGN(./.)
36000	CC	GO TO 536
36100	537	T=IFIX(ALOG(RH)/0.6931472+.001)-2.
36200	536	R(5,JZ)=T
36300	CCC	GO TO 337
36400	C*******  4/74  NEW WAY TO FIND TAILS
36500	C  OMITS RESTS  (REALLY???)
36600	CCC334	R(7,JZ)=T+R(7,JZ)
36700	337	IF(K.LT.IZ)GO TO 3
36800	CXXXXXXXX	M=NTC+1		XXXXXXXXX 9/28/78
36900	C********* WAS M=NTC ******* 4/14/78
37000		M=NTC
37100		DO 335 K=IZ,1,-1
37200		IF(R(3,K).GE.0)GO TO 335
37300		IF(K.NE.IZ)GO TO 336
37400		R(3,K)=POS2-4.
37500		GO TO 335
37600	336	N=K-1
37700	1336	RA=R(3,N)
37800		IF(RA.GT.0)GO TO 2336
37900		N=N-1
38000		IF(N.GT.0)GO TO 1336
38100	C GO BACK (IF MORE GRACE NOTES.) TO FIND PREVIOUS BIG NOTE.
38200	2336	T=R(3,K+1)
38300		RB=T-RA
38400		RA=3
38500		IF(RB.LE.4)RA=RB/2.
38600	C IF SPACE IS SMALL USE 1/3 OF IT.
38700		RB=T-RA
38800	C NEXT FOR GRACE NOTE CHORDS
38900		IF(R(8,K+1).GE.0)GO TO 1335
39000		RB=T
39100	CC	RB=R(3,K+1)
39200	CXXXX	M=M+1
39300	1335	R(3,K)=RB
39400		POSNT(M)=RB
39500	335	IF(R(8,K).GE.0.AND.R(1,K).EQ.1)M=M-1
39600	C COUNT ONLY NOTES - BUT NOT NON-RHYTH CHORD NOTES.
39700		K=0
39800	45	K=K+1
39900	C  NEXT IS TO ARRANGE DOTS.
40000		IF(R(7,K).LT.10)GO TO 451
40100		RA=R(3,K)
40200		DO 452 M=K+1,IZ
40300		IF(R(3,M).NE.RA)GO TO 453
40400	C  JUMP IF NOT CHORD NOTE.
40500		T=R(7,M)
40600		RB=R(4,M)
40700		IF(T.LT.100.)GO TO 452
40800	C  JUMP IF NOTE IS NOT ON LEFT SIDE OF UPWARD STEM
40900		IF(RB-R(4,M-1).NE.2)GO TO 452
41000		IF(AMOD(RB,2.).NE.0)R(7,M)=AMOD(T,10.)
41100	C  TAKES AWAY DOT IN CERTAIN CASES TO AVOID CONFUSION.
41200	452	CONTINUE
41300	453	K=M-1
41400	451	IF(K.LT.IZ)GO TO 45
41500	
41600		IF(ICNTPT)GO TO 13
41700		DO 113 K=1,IZ 
41800		RA=R(1,K)
41900		IF(RA.GT.2)GO TO 113
42000	C THIS ZEROS RHYTH PARAM IF NOTES WERE ALREADY ON THIS LINE.
42100		J=9
42200		IF(RA.EQ.2)J=7
42300		R(J,K)=0
42400	113	CONTINUE
42500	13	N=IZ
42600		NTC=NTC+1
42700		POSNT(NTC)=200
42800		POSNT(0)=0
42900		IF(IREAD.GE.0.AND.IDEV.EQ.5)CALL NOTNUM
43000		END
43100	
43200		SUBROUTINE NOTNUM
43300	CC	DIMENSION ISU(390)
43400		COMMON R2,JH,CENTR,J2,R3,R4,R5,RJQ(17),J3,J4,J5,JQ(17)
43500		1 /RINP/R(10,85),POSNT(0/99)
43600		1 /RMOD/RMODE2,SET4,IBEAM,NOSET,STEM,STUP,NTC,PS2
43700		1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
43800		1 /POSI/STFF(0/7),JJ2,POSQ /DPY/ST(4000),MEDIT,GO
43900		CALL DPYSET(3,ST(3600),390)
44000		CALL DPYBRT(6)
44100		J2=STAFF
44200		POSQ=STFF(J2)
44300		J5=1
44400		R4=20
44500	C  R5=0=1  STANDARD SIZE IS USED.
44600		DO 131 K=1,NTC-1
44700		R3=RHORZ(POSNT(K))
44800		CALL PNUM
44900	C  GOES TO DRAW A NUMBER OVER A NOTE
45000		J5=J5+1
45100		IF(J5.EQ.10)J5=0
45200	131	CONTINUE
45300	132	CALL DPYOUT(3)
45400		CALL SETPOG(1)
45500		END
45600	
45700		SUBROUTINE DOTS(VAL,RH,K,DOT)
45800		COMMON/SCM/V(1)
45900	C FINDS DOTS (1000S), GET RHYTH. AND RHYTHMIC VALUE (QTR=1)
46000		RH=V(K)
46100		IF(RH.EQ.0)RH=88.
46200		VAL=4/RH
46300		J=RH/1000.
46400		DOT=J*10
46500		IF(J.EQ.0)RETURN 
46600		RH=RH-J*1000
46700		VAL=4./RH
46800		Z=VAL
46900	1	Z=Z/2
47000		VAL=VAL+Z
47100		J=J-1
47200		IF(J.GT.0)GO TO 1
47300		END